Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/libguile/eval.c

C/C++ Source or Header | 1995-06-16 | 46.7 KB | 2,153 lines

/*    Copyright (C) 1995 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.
 */


#include <stdio.h>
#include "_scm.h"



/* A resolved global variable reference in the CAR position
 * of a list is stored (in code only) as a pointer to a pair with a
 * tag of 1.  This is called a "gloc".
 */

#define GLOC_SYM(x) (CAR((x)-1L))
#define GLOC_VAL(x) (CDR((x)-1L))



#define EVALCELLCAR(x, env) (SYMBOLP (CAR(x)) \
                 ? *scm_lookupcar(x, env) \
                 : scm_ceval(CAR(x), env))

#ifdef MEMOIZE_LOCALS
#define EVALIMP(x, env) (ILOCP(x)?*scm_ilookup((x), env):x)
#else
#define EVALIMP(x, env) x
#endif
#define EVALCAR(x, env) (NCELLP(CAR(x))\
            ? (IMP(CAR(x)) \
               ? EVALIMP(CAR(x), env) \
               : GLOC_VAL(CAR(x))) \
            : EVALCELLCAR(x, env))

#define EXTEND_ENV scm_acons

/* This variable holds the thunk used to lookup top-level variables.
 */
SCM scm_top_level_lookup_thunk_var;

#ifdef MEMOIZE_LOCALS
#ifdef __STDC__
SCM *
scm_ilookup (SCM iloc, SCM env)
#else
SCM *
scm_ilookup (iloc, env)
     SCM iloc;
     SCM env;
#endif
{
  register int ir = IFRAME (iloc);
  register SCM er = env;
  for (; 0 != ir; --ir)
    er = CDR (er);
  er = CAR (er);
  for (ir = IDIST (iloc); 0 != ir; --ir)
    er = CDR (er);
  if (ICDRP (iloc))
    return &CDR (er);
  return &CAR (CDR (er));
}
#endif

#ifdef __STDC__
SCM *
scm_lookupcar (SCM vloc, SCM genv)
#else
SCM *
scm_lookupcar (vloc, genv)
     SCM vloc;
     SCM genv;
#endif
{
  SCM env = genv;
  register SCM *al, fl, var = CAR (vloc);
#ifdef MEMOIZE_LOCALS
  register SCM iloc = ILOC00;
#endif
  for (; NIMP (env); env = CDR (env))
    {
      if (BOOL_T == scm_procedurep (CAR (env)))
    break;
      al = &CAR (env);
      for (fl = CAR (*al); NIMP (fl); fl = CDR (fl))
    {
      if (NCONSP (fl))
          if (fl == var)
          {
#ifdef MEMOIZE_LOCALS
        CAR (vloc) = iloc + ICDR;
#endif
        return &CDR (*al);
          }
        else
          break;
      al = &CDR (*al);
      if (CAR (fl) == var)
        {
#ifdef MEMOIZE_LOCALS
#ifndef RECKLESS        /* letrec inits to SCM_UNDEFINED */
          if (UNBNDP (CAR (*al)))
        {
          env = EOL;
          goto errout;
        }
#endif
          CAR (vloc) = iloc;
#endif
          return &CAR (*al);
        }
#ifdef MEMOIZE_LOCALS
      iloc += IDINC;
#endif
    }
#ifdef MEMOIZE_LOCALS
      iloc = (~IDSTMSK) & (iloc + IFRINC);
#endif
    }
  {
    SCM top_thunk, vcell;
    if (NIMP(env))
      {
    top_thunk = CAR(env);    /* env now refers to a top level env thunk */
    env = CDR (env);
      }
    else
      top_thunk = BOOL_F;
    vcell = scm_sym2vcell (var, top_thunk, BOOL_F);
    if (vcell == BOOL_F)
      goto errout;
    else
      var = vcell;
  }
#ifndef RECKLESS
  if (NNULLP (env) || UNBNDP (CDR (var)))
    {
      var = CAR (var);
    errout:
      scm_everr (vloc, genv, var,
         (NULLP (env)
          ? "unbound variable: "
          : "damaged environment"),
         "");
    }
#endif
  CAR (vloc) = var + 1;
  return &CDR (var);
}

#ifdef __STDC__
static SCM
unmemocar (SCM form, SCM env)
#else
static SCM
unmemocar (form, env)
     SCM form;
     SCM env;
#endif
{
  register int ir;
  if (IMP (form))
    return form;
  if (1 == TYP3 (form))
    CAR (form) = GLOC_SYM (CAR (form));
#ifdef MEMOIZE_LOCALS
  else if (ILOCP (form))
    {
      for (ir = IFRAME (CAR (form)); ir != 0; --ir)
    env = CDR (env);
      env = CAR (CAR (env));
      for (ir = IDIST (CAR (form)); ir != 0; --ir)
    env = CDR (env);
      CAR (form) = ICDRP (CAR (form)) ? env : CAR (env);
    }
#endif
  return form;
}

#ifdef __STDC__
SCM
scm_eval_args (SCM l, SCM env)
#else
SCM
scm_eval_args (l, env)
     SCM l;
     SCM env;
#endif
{
  SCM res = EOL, *lloc = &res;
  while (NIMP (l))
    {
      *lloc = scm_cons (EVALCAR (l, env), EOL);
      lloc = &CDR (*lloc);
      l = CDR (l);
    }
  return res;
}

/*
 * The following rewrite expressions and
 * some memoized forms have different syntax
 */

static char s_expression[] = "missing or extra expression";
static char s_test[] = "bad test";
static char s_body[] = "bad body";
static char s_bindings[] = "bad bindings";
static char s_variable[] = "bad variable";
static char s_clauses[] = "bad or missing clauses";
static char s_formals[] = "bad formals";
#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);

SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let,
  scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";

#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);


#ifdef __STDC__
static void
bodycheck (SCM xorig, SCM *bodyloc, char *what)
#else
static void
bodycheck (xorig, bodyloc, what)
     SCM xorig;
     SCM *bodyloc;
     char *what;
#endif
{
  ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression);
}


#ifdef __STDC__
SCM
scm_m_quote (SCM xorig, SCM env)
#else
SCM
scm_m_quote (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  ASSYNT (scm_ilength (CDR (xorig)) == 1, xorig, s_expression, "quote");
  return scm_cons (IM_QUOTE, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_begin (SCM xorig, SCM env)
#else
SCM
scm_m_begin (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  ASSYNT (scm_ilength (CDR (xorig)) >= 1, xorig, s_expression, "begin");
  return scm_cons (IM_BEGIN, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_if (SCM xorig, SCM env)
#else
SCM
scm_m_if (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if");
  return scm_cons (IM_IF, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_set (SCM xorig, SCM env)
#else
SCM
scm_m_set (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig);
  ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!");
  ASSYNT (NIMP (CAR (x)) && SYMBOLP (CAR (x)),
      xorig, s_variable, "set!");
  return scm_cons (IM_SET, x);
}


#if 0
#ifdef __STDC__
SCM
scm_m_vref (SCM xorig, SCM env)
#else
SCM
scm_m_vref (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig);
  ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
  if (NIMP(x) && UDVARIABLEP (CAR (x)))
    {
      scm_everr (SCM_UNDEFINED, env, CAR(CDR(x)), s_variable,
         "global variable reference");
    }
  ASSYNT (NIMP(x) && DEFVARIABLEP (CAR (x)),
      xorig, s_variable, s_vref);
  return
  return scm_cons (IM_VREF, x);
}


#ifdef __STDC__
SCM
scm_m_vset (SCM xorig, SCM env)
#else
SCM
scm_m_vset (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig);
  ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
  ASSYNT ((   DEFVARIABLEP (CAR (x))
       || UDVARIABLEP (CAR (x))),
      xorig, s_variable, s_vset);
  return scm_cons (IM_VSET, x);
}
#endif


#ifdef __STDC__
SCM
scm_m_and (SCM xorig, SCM env)
#else
SCM
scm_m_and (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, "and");
  if (len >= 1)
    return scm_cons (IM_AND, CDR (xorig));
  else
    return BOOL_T;
}


#ifdef __STDC__
SCM
scm_m_or (SCM xorig, SCM env)
#else
SCM
scm_m_or (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  int len = scm_ilength (CDR (xorig));
  ASSYNT (len >= 0, xorig, s_test, "or");
  if (len >= 1)
    return scm_cons (IM_OR, CDR (xorig));
  else
    return BOOL_F;
}


#ifdef __STDC__
SCM
scm_m_case (SCM xorig, SCM env)
#else
SCM
scm_m_case (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM proc, x = CDR (xorig);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case");
  while (NIMP (x = CDR (x)))
    {
      proc = CAR (x);
      ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, "case");
      ASSYNT (scm_ilength (CAR (proc)) >= 0 || scm_i_else == CAR (proc),
          xorig, s_clauses, "case");
    }
  return scm_cons (IM_CASE, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_cond (SCM xorig, SCM env)
#else
SCM
scm_m_cond (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM arg1, x = CDR (xorig);
  int len = scm_ilength (x);
  ASSYNT (len >= 1, xorig, s_clauses, "cond");
  while (NIMP (x))
    {
      arg1 = CAR (x);
      len = scm_ilength (arg1);
      ASSYNT (len >= 1, xorig, s_clauses, "cond");
      if (scm_i_else == CAR (arg1))
    {
      ASSYNT (NULLP (CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
      CAR (arg1) = BOOL_T;
    }
      if (len >= 2 && scm_i_arrow == CAR (CDR (arg1)))
    ASSYNT (3 == len && NIMP (CAR (CDR (CDR (arg1)))),
        xorig, "bad recipient", "cond");
      x = CDR (x);
    }
  return scm_cons (IM_COND, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_lambda (SCM xorig, SCM env)
#else
SCM
scm_m_lambda (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM proc, x = CDR (xorig);
  if (scm_ilength (x) < 2)
    goto badforms;
  proc = CAR (x);
  if NULLP
    (proc) goto memlambda;
  if IMP
    (proc) goto badforms;
  if SYMBOLP
    (proc) goto memlambda;
  if NCONSP
    (proc) goto badforms;
  while NIMP
    (proc)
    {
      if NCONSP
    (proc)
      if (!SYMBOLP (proc))
      goto badforms;
    else
      goto memlambda;
      if (!(NIMP (CAR (proc)) && SYMBOLP (CAR (proc))))
    goto badforms;
      proc = CDR (proc);
    }
  if NNULLP
    (proc)
  badforms:scm_wta (xorig, s_formals, "lambda");
memlambda:
  bodycheck (xorig, &CDR (x), "lambda");
  return scm_cons (IM_LAMBDA, CDR (xorig));
}


#ifdef __STDC__
SCM
scm_m_letstar (SCM xorig, SCM env)
#else
SCM
scm_m_letstar (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig), arg1, proc, vars = EOL, *varloc = &vars;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_body, "let*");
  proc = CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
  while NIMP
    (proc)
    {
      arg1 = CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, "let*");
      *varloc = scm_cons2 (CAR (arg1), CAR (CDR (arg1)), EOL);
      varloc = &CDR (CDR (*varloc));
      proc = CDR (proc);
    }
  x = scm_cons (vars, CDR (x));
  bodycheck (xorig, &CDR (x), "let*");
  return scm_cons (IM_LETSTAR, x);
}

/* DO gets the most radically altered syntax
   (do ((<var1> <init1> <step1>)
   (<var2> <init2>)
   ... )
   (<test> <return>)
   <body>)
   ;; becomes
   (do_mem (varn ... var2 var1)
   (<init1> <init2> ... <initn>)
   (<test> <return>)
   (<body>)
   <step1> <step2> ... <stepn>) ;; missing steps replaced by var
   */


#ifdef __STDC__
SCM
scm_m_do (SCM xorig, SCM env)
#else
SCM
scm_m_do (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig), arg1, proc;
  SCM vars = EOL, inits = EOL, steps = EOL;
  SCM *initloc = &inits, *steploc = &steps;
  int len = scm_ilength (x);
  ASSYNT (len >= 2, xorig, s_test, "do");
  proc = CAR (x);
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do");
  while NIMP
    (proc)
    {
      arg1 = CAR (proc);
      len = scm_ilength (arg1);
      ASSYNT (2 == len || 3 == len, xorig, s_bindings, "do");
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, "do");
      /* vars reversed here, inits and steps reversed at evaluation */
      vars = scm_cons (CAR (arg1), vars);    /* variable */
      arg1 = CDR (arg1);
      *initloc = scm_cons (CAR (arg1), EOL);    /* init */
      initloc = &CDR (*initloc);
      arg1 = CDR (arg1);
      *steploc = scm_cons (IMP (arg1) ? CAR (vars) : CAR (arg1), EOL);    /* step */
      steploc = &CDR (*steploc);
      proc = CDR (proc);
    }
  x = CDR (x);
  ASSYNT (scm_ilength (CAR (x)) >= 1, xorig, s_test, "do");
  x = scm_cons2 (CAR (x), CDR (x), steps);
  x = scm_cons2 (vars, inits, x);
  bodycheck (xorig, &CAR (CDR (CDR (x))), "do");
  return scm_cons (IM_DO, x);
}

/* evalcar is small version of inline EVALCAR when we don't care about speed */
#ifdef __STDC__
static SCM
evalcar (SCM x, SCM env)
#else
static SCM
evalcar (x, env)
     SCM x;
     SCM env;
#endif
{
  return EVALCAR (x, env);
}

#ifdef __STDC__
static SCM
iqq (SCM form, SCM env, int depth)
#else
static SCM
iqq (form, env, depth)
     SCM form;
     SCM env;
     int depth;
#endif
{
  SCM tmp;
  int edepth = depth;
  if IMP
    (form) return form;
  if VECTORP
    (form)
    {
      long i = LENGTH (form);
      SCM *data = VELTS (form);
      tmp = EOL;
      for (; --i >= 0;)
    tmp = scm_cons (data[i], tmp);
      return scm_vector (iqq (tmp, env, depth));
    }
  if NCONSP
    (form) return form;
  tmp = CAR (form);
  if (scm_i_quasiquote == tmp)
    {
      depth++;
      goto label;
    }
  if (scm_i_unquote == tmp)
    {
      --depth;
    label:
      form = CDR (form);
      ASSERT (NIMP (form) && ECONSP (form) && NULLP (CDR (form)),
          form, ARG1, s_quasiquote);
      if (0 == depth)
    return evalcar (form, env);
      return scm_cons2 (tmp, iqq (CAR (form), env, depth), EOL);
    }
  if (NIMP (tmp) && (scm_i_uq_splicing == CAR (tmp)))
    {
      tmp = CDR (tmp);
      if (0 == --edepth)
    return scm_append (scm_cons2 (evalcar (tmp, env), iqq (CDR (form), env, depth), EOL));
    }
  return scm_cons (iqq (CAR (form), env, edepth), iqq (CDR (form), env, depth));
}

/* Here are acros which return values rather than code. */

#ifdef __STDC__
SCM
scm_m_quasiquote (SCM xorig, SCM env)
#else
SCM
scm_m_quasiquote (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM x = CDR (xorig);
  ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote);
  return iqq (CAR (x), env, 1);
}

#ifdef __STDC__
SCM
scm_m_delay (SCM xorig, SCM env)
#else
SCM
scm_m_delay (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
  xorig = CDR (xorig);
  return scm_makprom (scm_closure (scm_cons2 (EOL, CAR (xorig), CDR (xorig)),
                   env));
}

#ifdef __STDC__
static SCM
env_top_level (SCM env)
#else
static SCM
env_top_level (env)
     SCM env;
#endif
{
  while (NIMP(env))
    {
      if (BOOL_T == scm_procedurep (CAR(env)))
    return CAR(env);
      env = CDR (env);
    }
  return BOOL_F;
}

extern int scm_verbose;
#ifdef __STDC__
SCM
scm_m_define (SCM x, SCM env)
#else
SCM
scm_m_define (x, env)
     SCM x;
     SCM env;
#endif
{
  SCM proc, arg1 = x;
  x = CDR (x);
  /*  ASSYNT(NULLP(env), x, "bad placement", s_define);*/
  ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, "define");
  proc = CAR (x);
  x = CDR (x);
  while (NIMP (proc) && CONSP (proc))
    {                /* nested define syntax */
      x = scm_cons (scm_cons2 (scm_i_lambda, CDR (proc), x), EOL);
      proc = CAR (proc);
    }
  ASSYNT (NIMP (proc) && SYMBOLP (proc), arg1, s_variable, "define");
  ASSYNT (1 == scm_ilength (x), arg1, s_expression, "define");
  if (TOP_LEVEL (env))
    {
      x = evalcar (x, env);
      arg1 = scm_sym2vcell (proc, env_top_level (env), BOOL_T);
#ifndef RECKLESS
      if (NIMP (CDR (arg1)) && ((SCM) SNAME (CDR (arg1)) == proc)
      && (CDR (arg1) != x))
    scm_warn ("redefining built-in ", CHARS (proc));
      else
#endif
      if (5 <= scm_verbose && SCM_UNDEFINED != CDR (arg1))
    scm_warn ("redefining ", CHARS (proc));
      CDR (arg1) = x;
#ifdef SICP
      return scm_cons2 (scm_i_quote, CAR (arg1), EOL);
#else
      return UNSPECIFIED;
#endif
    }
  return scm_cons2 (IM_DEFINE, proc, x);
}
/* end of acros */

#ifdef __STDC__
SCM
scm_m_letrec (SCM xorig, SCM env)
#else
SCM
scm_m_letrec (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM cdrx = CDR (xorig);    /* locally mutable version of form */
  char *what = CHARS (CAR (xorig));
  SCM x = cdrx, proc, arg1;    /* structure traversers */
  SCM vars = EOL, inits = EOL, *initloc = &inits;

  ASRTSYNTAX (scm_ilength (x) >= 2, s_body);
  proc = CAR (x);
  if NULLP
    (proc) return scm_m_letstar (xorig, env);    /* null binding, let* faster */
  ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings);
  do
    {
      /* vars scm_list reversed here, inits reversed at evaluation */
      arg1 = CAR (proc);
      ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings);
      ASRTSYNTAX (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), s_variable);
      vars = scm_cons (CAR (arg1), vars);
      *initloc = scm_cons (CAR (CDR (arg1)), EOL);
      initloc = &CDR (*initloc);
    }
  while NIMP
  (proc = CDR (proc));
  cdrx = scm_cons2 (vars, inits, CDR (x));
  bodycheck (xorig, &CDR (CDR (cdrx)), what);
  return scm_cons (IM_LETREC, cdrx);
}

#ifdef __STDC__
SCM
scm_m_let (SCM xorig, SCM env)
#else
SCM
scm_m_let (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  SCM cdrx = CDR (xorig);    /* locally mutable version of form */
  SCM x = cdrx, proc, arg1, name;    /* structure traversers */
  SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits;

  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
  proc = CAR (x);
  if (NULLP (proc)
      || (NIMP (proc) && CONSP (proc)
      && NIMP (CAR (proc)) && CONSP (CAR (proc)) && NULLP (CDR (proc))))
    return scm_m_letstar (xorig, env);    /* null or single binding, let* is faster */
  ASSYNT (NIMP (proc), xorig, s_bindings, "let");
  if (CONSP (proc))            /* plain let, proc is <bindings> */
      return scm_cons (IM_LET, CDR (scm_m_letrec (xorig, env)));
  if (!SYMBOLP (proc))
    scm_wta (xorig, s_bindings, "let");    /* bad let */
  name = proc;            /* named let, build equiv letrec */
  x = CDR (x);
  ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let");
  proc = CAR (x);        /* bindings scm_list */
  ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let");
  while NIMP
    (proc)
    {                /* vars and inits both in order */
      arg1 = CAR (proc);
      ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
      ASSYNT (NIMP (CAR (arg1)) && SYMBOLP (CAR (arg1)), xorig, s_variable, "let");
      *varloc = scm_cons (CAR (arg1), EOL);
      varloc = &CDR (*varloc);
      *initloc = scm_cons (CAR (CDR (arg1)), EOL);
      initloc = &CDR (*initloc);
      proc = CDR (proc);
    }
  return
    scm_m_letrec (scm_cons2 (scm_i_let,
                 scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, CDR (x)), EOL), EOL),
                 scm_acons (name, inits, EOL)),     /* body */
          env);
}

#define s_atapply (ISYMCHARS(IM_APPLY)+1)

#ifdef __STDC__
SCM
scm_m_apply (SCM xorig, SCM env)
#else
SCM
scm_m_apply (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  ASSYNT (scm_ilength (CDR (xorig)) == 2, xorig, s_expression, "@apply");
  return scm_cons (IM_APPLY, CDR (xorig));
}

#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)

#ifdef __STDC__
SCM
scm_m_cont (SCM xorig, SCM env)
#else
SCM
scm_m_cont (xorig, env)
     SCM xorig;
     SCM env;
#endif
{
  ASSYNT (scm_ilength (CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation");
  return scm_cons (IM_CONT, CDR (xorig));
}

#ifndef RECKLESS
#ifdef __STDC__
int
scm_badargsp (SCM formals, SCM args)
#else
int
scm_badargsp (formals, args)
     SCM formals;
     SCM args;
#endif
{
  while NIMP
    (formals)
    {
      if NCONSP
    (formals) return 0;
      if IMP
    (args) return 1;
      formals = CDR (formals);
      args = CDR (args);
    }
  return NNULLP (args) ? 1 : 0;
}
#endif



static char scm_s_map[];
static char scm_s_for_each[];
long scm_tc16_macro;

#ifdef __STDC__
SCM
scm_ceval (SCM x, SCM env)
#else
SCM
scm_ceval (x, env)
     SCM x;
     SCM env;
#endif
{
  union
    {
      SCM *lloc;
      SCM arg1;
    } t;
  SCM proc, arg2;
  CHECK_STACK;
loop:POLL;
  switch (TYP7 (x))
    {
    case tcs_symbols:
      /* only happens when called at top level */
      x = scm_cons (x, SCM_UNDEFINED);
      goto retval;
    case (127 & IM_AND):
      x = CDR (x);
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
    if FALSEP (EVALCAR (x, env)) return BOOL_F;
    else
      x = t.arg1;
      goto carloop;
    case (127 & IM_BEGIN):
    cdrxbegin:
      x = CDR (x);
    begin:
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
    {
      SIDEVAL (CAR (x), env);
      x = t.arg1;
    }
    carloop:            /* scm_eval car of last form in scm_list */
      if (NCELLP (CAR (x)))
    {
      x = CAR (x);
      return IMP (x) ? EVALIMP (x, env) : GLOC_VAL (x);
    }
      if (SYMBOLP (CAR (x)))
    {
    retval:
      return *scm_lookupcar (x, env);
    }
      x = CAR (x);
      goto loop;        /* tail recurse */

    case (127 & IM_CASE):
      x = CDR (x);
      t.arg1 = EVALCAR (x, env);
      while (NIMP (x = CDR (x)))
    {
      proc = CAR (x);
      if (scm_i_else == CAR (proc))
        {
          x = CDR (proc);
          goto begin;
        }
      proc = CAR (proc);
      while (NIMP (proc))
        {
          if (CAR (proc) == t.arg1
#ifdef FLOATS
          || NFALSEP (scm_eqv_p (CAR (proc), t.arg1))
#endif
        )
        {
          x = CDR (CAR (x));
          goto begin;
        }
          proc = CDR (proc);
        }
    }
      return UNSPECIFIED;
    case (127 & IM_COND):
      while (NIMP (x = CDR (x)))
    {
      proc = CAR (x);
      t.arg1 = EVALCAR (proc, env);
      if NFALSEP
        (t.arg1)
        {
          x = CDR (proc);
          if NULLP
        (x) return t.arg1;
          if (scm_i_arrow != CAR (x))
        goto begin;
          proc = CDR (x);
          proc = EVALCAR (proc, env);
          ASRTGO (NIMP (proc), badfun);
          goto evap1;
        }
    }
      return UNSPECIFIED;
    case (127 & IM_DO):
      x = CDR (x);
      proc = CAR (CDR (x));    /* inits */
      t.arg1 = EOL;        /* values */
      while (NIMP (proc))
    {
      t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
      proc = CDR (proc);
    }
      env = EXTEND_ENV (CAR (x), t.arg1, env);
      x = CDR (CDR (x));
      while (proc = CAR (x), FALSEP (EVALCAR (proc, env)))
    {
      for (proc = CAR (CDR (x)); NIMP (proc); proc = CDR (proc))
        {
          t.arg1 = CAR (proc);    /* body */
          SIDEVAL (t.arg1, env);
        }
      for (t.arg1 = EOL, proc = CDR (CDR (x)); NIMP (proc); proc = CDR (proc))
        t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);    /* steps */
      env = EXTEND_ENV (CAR (CAR (env)), t.arg1, CDR (env));
    }
      x = CDR (proc);
      if NULLP (x)
    return UNSPECIFIED;
      goto begin;
    case (127 & IM_IF):
      x = CDR (x);
      if NFALSEP
    (EVALCAR (x, env)) x = CDR (x);
      else if IMP
    (x = CDR (CDR (x))) return UNSPECIFIED;
      goto carloop;
    case (127 & IM_LET):
      x = CDR (x);
      proc = CAR (CDR (x));
      t.arg1 = EOL;
      do
    {
      t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
    }
      while NIMP
      (proc = CDR (proc));
      env = EXTEND_ENV (CAR (x), t.arg1, env);
      x = CDR (x);
      goto cdrxbegin;
    case (127 & IM_LETREC):
      x = CDR (x);
      env = EXTEND_ENV (CAR (x), undefineds, env);
      x = CDR (x);
      proc = CAR (x);
      t.arg1 = EOL;
      do
    {
      t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
    }
      while NIMP
      (proc = CDR (proc));
      CDR (CAR (env)) = t.arg1;
      goto cdrxbegin;
    case (127 & IM_LETSTAR):
      x = CDR (x);
      proc = CAR (x);
      if IMP
    (proc)
    {
      env = EXTEND_ENV (EOL, EOL, env);
      goto cdrxbegin;
    }
      do
    {
      t.arg1 = CAR (proc);
      proc = CDR (proc);
      env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
    }
      while NIMP
      (proc = CDR (proc));
      goto cdrxbegin;
    case (127 & IM_OR):
      x = CDR (x);
      t.arg1 = x;
      while (NNULLP (t.arg1 = CDR (t.arg1)))
    {
      x = EVALCAR (x, env);
      if NFALSEP
        (x) return x;
      x = t.arg1;
    }
      goto carloop;
    case (127 & IM_LAMBDA):
      return scm_closure (CDR (x), env);
    case (127 & IM_QUOTE):
      return CAR (CDR (x));
    case (127 & IM_SET):
      x = CDR (x);
      proc = CAR (x);
      switch (7 & (int) proc)
    {
    case 0:
      t.lloc = scm_lookupcar (x, env);
      break;
    case 1:
      t.lloc = &GLOC_VAL (proc);
      break;
#ifdef MEMOIZE_LOCALS
    case 4:
      t.lloc = scm_ilookup (proc, env);
      break;
#endif
    }
      x = CDR (x);
      *t.lloc = EVALCAR (x, env);
#ifdef SICP
      return *t.lloc;
#else
      return UNSPECIFIED;
#endif
    case (127 & IM_DEFINE):    /* only for internal defines */
      x = CDR (x);
      proc = CAR (x);
      x = CDR (x);
      x = evalcar (x, env);
      env = CAR (env);
      DEFER_INTS;
      CAR (env) = scm_cons (proc, CAR (env));
      CDR (env) = scm_cons (x, CDR (env));
      ALLOW_INTS;
      return UNSPECIFIED;
      /* new syntactic forms go here. */
    case (127 & MAKISYM (0)):
      proc = CAR (x);
      ASRTGO (ISYMP (proc), badfun);
      switch ISYMNUM (proc)
    {
#if 0
    case (ISYMNUM (IM_VREF)):
      {
        SCM var;
        var = CAR (CDR (x));
        return CDR(var);
      }
    case (ISYMNUM (IM_VSET)):
      CDR (CAR ( CDR (x))) = EVALCAR( CDR ( CDR (x)), env);
      CAR (CAR ( CDR (x))) = scm_tc16_variable;
      return UNSPECIFIED;
#endif
    case (ISYMNUM (IM_APPLY)):
      proc = CDR (x);
      proc = EVALCAR (proc, env);
      ASRTGO (NIMP (proc), badfun);
      if (CLOSUREP (proc))
        {
          t.arg1 = CDR (CDR (x));
          t.arg1 = EVALCAR (t.arg1, env);
#ifndef RECKLESS
          if (scm_badargsp (CAR (CODE (proc)), t.arg1))
        goto wrongnumargs;
#endif
          env = EXTEND_ENV (CAR (CODE (proc)), t.arg1, ENV (proc));
          x = CODE (proc);
          goto cdrxbegin;
        }
      proc = scm_i_apply;
      goto evapply;
    case (ISYMNUM (IM_CONT)):
      t.arg1 = scm_make_cont ();
      if (setjmp (JMPBUF (t.arg1)))
        return scm_throwval;
      proc = CDR (x);
      proc = evalcar (proc, env);
      ASRTGO (NIMP (proc), badfun);
      goto evap1;
    default:
      goto badfun;
    }
    default:
      proc = x;
    badfun:
      scm_everr (x, env, proc, "Wrong type to apply: ", "");
    case tc7_vector:
    case tc7_bvect:
    case tc7_ivect:
    case tc7_uvect:
    case tc7_fvect:
    case tc7_dvect:
    case tc7_cvect:
    case tc7_string:
    case tc7_smob:
    case tcs_closures:
    case tcs_subrs:
      return x;
#ifdef MEMOIZE_LOCALS
    case (127 & ILOC00):
      proc = *scm_ilookup (CAR (x), env);
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;
#endif /* ifdef MEMOIZE_LOCALS */
    case tcs_cons_gloc:
      proc = GLOC_VAL (CAR (x));
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
      goto checkargs;
#endif
#endif
      break;
    case tcs_cons_nimcar:
      if (SYMBOLP (CAR (x)))
    {
      proc = *scm_lookupcar (x, env);
      if (IMP (proc))
        {
          unmemocar (x, env);
          goto badfun;
        }
      if (scm_tc16_macro == TYP16 (proc))
        {
          unmemocar (x, env);
          t.arg1 = scm_apply (CDR (proc), x, scm_cons (env, listofnull));
          switch ((int) (CAR (proc) >> 16))
        {
        case 2:
          if (scm_ilength (t.arg1) <= 0)
            t.arg1 = scm_cons2 (IM_BEGIN, t.arg1, EOL);
          DEFER_INTS;
          CAR (x) = CAR (t.arg1);
          CDR (x) = CDR (t.arg1);
          ALLOW_INTS;
          goto loop;
        case 1:
          if (NIMP (x = t.arg1))
            goto loop;
        case 0:
          return t.arg1;
        }
        }
    }
      else
    proc = scm_ceval (CAR (x), env);
      ASRTGO (NIMP (proc), badfun);
#ifndef RECKLESS
#ifdef CAUTIOUS
    checkargs:
#endif
      if (CLOSUREP (proc))
    {
      arg2 = CAR (CODE (proc));
      t.arg1 = CDR (x);
      while (NIMP (arg2))
        {
          if (NCONSP (arg2))
          goto evapply;
          if (IMP (t.arg1))
        goto umwrongnumargs;
          arg2 = CDR (arg2);
          t.arg1 = CDR (t.arg1);
        }
      if (NNULLP (t.arg1))
        goto umwrongnumargs;
    }
#endif
    }
evapply:
  if (NULLP (CDR (x)))
    switch (TYP7 (proc))
      {                /* no arguments given */
      case tc7_subr_0:
    return SUBRF (proc) ();
      case tc7_subr_1o:
    return SUBRF (proc) (SCM_UNDEFINED);
      case tc7_lsubr:
    return SUBRF (proc) (EOL);
      case tc7_rpsubr:
    return BOOL_T;
      case tc7_asubr:
    return SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
#ifdef CCLO
      case tc7_cclo:
    t.arg1 = proc;
    proc = CCLO_SUBR (proc);
    goto evap1;
#endif
      case tcs_closures:
    x = CODE (proc);
    env = EXTEND_ENV (CAR (x), EOL, ENV (proc));
    goto cdrxbegin;
      case tc7_contin:
      case tc7_subr_1:
      case tc7_subr_2:
      case tc7_subr_2o:
      case tc7_cxr:
      case tc7_subr_3:
      case tc7_lsubr_2:
      umwrongnumargs:
    unmemocar (x, env);
      wrongnumargs:
    scm_everr (x, env, proc, (char *) WNA, "");
      default:
    goto badfun;
      }
  x = CDR (x);
#ifdef CAUTIOUS
  if (IMP (x))
    goto wrongnumargs;
#endif
  t.arg1 = EVALCAR (x, env);
  x = CDR (x);
  if (NULLP (x))
  evap1:
    switch (TYP7 (proc))
      {                /* have one argument in t.arg1 */
      case tc7_subr_2o:
    return SUBRF (proc) (t.arg1, SCM_UNDEFINED);
      case tc7_subr_1:
      case tc7_subr_1o:
    return SUBRF (proc) (t.arg1);
      case tc7_cxr:
#ifdef FLOATS
    if (SUBRF (proc))
      {
        if (INUMP (t.arg1))
        return scm_makdbl (DSUBRF (proc) ((double) INUM (t.arg1)),
                   0.0);
        ASRTGO (NIMP (t.arg1), floerr);
        if (REALP (t.arg1))
        return scm_makdbl (DSUBRF (proc) (REALPART (t.arg1)), 0.0);
#ifdef BIGDIG
        if (BIGP (t.arg1))
        return scm_makdbl (DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0);
#endif
      floerr:
        scm_wta (t.arg1, (char *) ARG1, CHARS (SNAME (proc)));
      }
#endif
    proc = (SCM) SNAME (proc);
    {
      char *chrs = CHARS (proc) + LENGTH (proc) - 1;
      while ('c' != *--chrs)
        {
          ASSERT (NIMP (t.arg1) && CONSP (t.arg1),
              t.arg1, ARG1, CHARS (proc));
          t.arg1 = ('a' == *chrs) ? CAR (t.arg1) : CDR (t.arg1);
        }
      return t.arg1;
    }
      case tc7_rpsubr:
    return BOOL_T;
      case tc7_asubr:
    return SUBRF (proc) (t.arg1, SCM_UNDEFINED);
      case tc7_lsubr:
    return SUBRF (proc) (scm_cons (t.arg1, EOL));
#ifdef CCLO
      case tc7_cclo:
    arg2 = t.arg1;
    t.arg1 = proc;
    proc = CCLO_SUBR (proc);
    goto evap2;
#endif
      case tcs_closures:
    x = CODE (proc);
    env = EXTEND_ENV (CAR (x), scm_cons (t.arg1, EOL), ENV (proc));
    goto cdrxbegin;
      case tc7_contin:
    scm_throw (proc, t.arg1);
      case tc7_subr_2:
      case tc7_subr_0:
      case tc7_subr_3:
      case tc7_lsubr_2:
    goto wrongnumargs;
      default:
    goto badfun;
      }
#ifdef CAUTIOUS
  if (IMP (x))
    goto wrongnumargs;
#endif
  {                /* have two or more arguments */
    arg2 = EVALCAR (x, env);
    x = CDR (x);
    if (NULLP (x))
#ifdef CCLO
    evap2:
#endif
      switch TYP7
    (proc)
    {            /* have two arguments */
    case tc7_subr_2:
    case tc7_subr_2o:
      return SUBRF (proc) (t.arg1, arg2);
    case tc7_lsubr:
      return SUBRF (proc) (scm_cons2 (t.arg1, arg2, EOL));
    case tc7_lsubr_2:
      return SUBRF (proc) (t.arg1, arg2, EOL);
    case tc7_rpsubr:
    case tc7_asubr:
      return SUBRF (proc) (t.arg1, arg2);
#ifdef CCLO
    cclon: case tc7_cclo:
      return scm_apply (CCLO_SUBR (proc), proc,
      scm_cons2 (t.arg1, arg2, scm_cons (scm_eval_args (x, env), EOL)));
/*    case tc7_cclo:
      x = scm_cons(arg2, scm_eval_args(x, env));
      arg2 = t.arg1;
      t.arg1 = proc;
      proc = CCLO_SUBR(proc);
      goto evap3; */
#endif
    case tc7_subr_0:
    case tc7_cxr:
    case tc7_subr_1o:
    case tc7_subr_1:
    case tc7_subr_3:
    case tc7_contin:
      goto wrongnumargs;
    default:
      goto badfun;
    case tcs_closures:
      env = EXTEND_ENV (CAR (CODE (proc)), scm_cons2 (t.arg1, arg2, EOL), ENV (proc));
      x = CODE (proc);
      goto cdrxbegin;
    }
    switch TYP7
      (proc)
      {                /* have 3 or more arguments */
      case tc7_subr_3:
    ASRTGO (NULLP (CDR (x)), wrongnumargs);
    return SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env));
      case tc7_asubr:
/*      t.arg1 = SUBRF(proc)(t.arg1, arg2);
      while NIMP(x) {
    t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
    x = CDR(x);
      }
      return t.arg1; */
      case tc7_rpsubr:
    return scm_apply (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), EOL));
      case tc7_lsubr_2:
    return SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env));
      case tc7_lsubr:
    return SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)));
#ifdef CCLO
      case tc7_cclo:
    goto cclon;
#endif
      case tcs_closures:
    env = EXTEND_ENV (CAR (CODE (proc)),
              scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
              ENV (proc));
    x = CODE (proc);
    goto cdrxbegin;
      case tc7_subr_2:
      case tc7_subr_1o:
      case tc7_subr_2o:
      case tc7_subr_0:
      case tc7_cxr:
      case tc7_subr_1:
      case tc7_contin:
    goto wrongnumargs;
      default:
    goto badfun;
      }
  }
}



PROC (s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
#ifdef __STDC__
SCM
scm_procedure_documentation (SCM proc)
#else
SCM
scm_procedure_documentation (proc)
     SCM proc;
#endif
{
  SCM code;
  ASSERT (BOOL_T == scm_procedurep (proc) && NIMP (proc) && TYP7 (proc) != tc7_contin,
      proc, ARG1, s_procedure_documentation);
  switch (TYP7 (proc))
    {
    case tcs_closures:
      code = CDR (CODE (proc));
      if (IMP (CDR (code)))
    return BOOL_F;
      code = CAR (code);
      if (IMP (code))
    return BOOL_F;
      if (STRINGP (code))
    return code;
    default:
      return BOOL_F;
/*
  case tcs_subrs:
#ifdef CCLO
  case tc7_cclo:
#endif
*/
    }
}

/* This code is for scm_apply. it is destructive on multiple args.
 * This will only screw you if you do (scm_apply scm_apply '( ... ))
 */
PROC (s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
#ifdef __STDC__
SCM
scm_nconc2last (SCM lst)
#else
SCM
scm_nconc2last (lst)
     SCM lst;
#endif
{
  SCM *lloc = &lst;
  while (NNULLP (CDR (*lloc)))
    lloc = &CDR (*lloc);
  *lloc = CAR (*lloc);
  return lst;
}


#ifdef __STDC__
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
#else
SCM
scm_apply (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
#endif
{
  ASRTGO (NIMP (proc), badproc);
  if (NULLP (args))
    if (NULLP (arg1))
      arg1 = SCM_UNDEFINED;
    else
      {
    args = CDR (arg1);
    arg1 = CAR (arg1);
      }
  else
    {
      /*        ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
      args = scm_nconc2last (args);
    }
#ifdef CCLO
tail:
#endif
  switch (TYP7 (proc))
    {
    case tc7_subr_2o:
      args = NULLP (args) ? SCM_UNDEFINED : CAR (args);
      return SUBRF (proc) (arg1, args);
    case tc7_subr_2:
      ASRTGO (NULLP (CDR (args)), wrongnumargs);
      args = CAR (args);
      return SUBRF (proc) (arg1, args);
    case tc7_subr_0:
      ASRTGO (UNBNDP (arg1), wrongnumargs);
      return SUBRF (proc) ();
    case tc7_subr_1:
    case tc7_subr_1o:
      ASRTGO (NULLP (args), wrongnumargs);
      return SUBRF (proc) (arg1);
    case tc7_cxr:
      ASRTGO (NULLP (args), wrongnumargs);
#ifdef FLOATS
      if (SUBRF (proc))
    {
      if INUMP
        (arg1)
          return scm_makdbl (DSUBRF (proc) ((double) INUM (arg1)), 0.0);
      ASRTGO (NIMP (arg1), floerr);
      if REALP
        (arg1)
          return scm_makdbl (DSUBRF (proc) (REALPART (arg1)), 0.0);
#ifdef BIGDIG
      if BIGP
        (arg1)
          return scm_makdbl (DSUBRF (proc) (scm_big2dbl (arg1)), 0.0);
#endif
    floerr:
      scm_wta (arg1, (char *) ARG1, CHARS (SNAME (proc)));
    }
#endif
      proc = (SCM) SNAME (proc);
      {
    char *chrs = CHARS (proc) + LENGTH (proc) - 1;
    while ('c' != *--chrs)
      {
        ASSERT (NIMP (arg1) && CONSP (arg1),
            arg1, ARG1, CHARS (proc));
        arg1 = ('a' == *chrs) ? CAR (arg1) : CDR (arg1);
      }
    return arg1;
      }
    case tc7_subr_3:
      return SUBRF (proc) (arg1, CAR (args), CAR (CDR (args)));
    case tc7_lsubr:
      return SUBRF (proc) (UNBNDP (arg1) ? EOL : scm_cons (arg1, args));
    case tc7_lsubr_2:
      ASRTGO (NIMP (args) && CONSP (args), wrongnumargs);
      return SUBRF (proc) (arg1, CAR (args), CDR (args));
    case tc7_asubr:
      if (NULLP (args))
    return SUBRF (proc) (arg1, SCM_UNDEFINED);
      while (NIMP (args))
    {
      ASSERT (CONSP (args), args, ARG2, "apply");
      arg1 = SUBRF (proc) (arg1, CAR (args));
      args = CDR (args);
    }
      return arg1;
    case tc7_rpsubr:
      if (NULLP (args))
    return BOOL_T;
      while (NIMP (args))
    {
      ASSERT (CONSP (args), args, ARG2, "apply");
      if FALSEP
        (SUBRF (proc) (arg1, CAR (args))) return BOOL_F;
      arg1 = CAR (args);
      args = CDR (args);
    }
      return BOOL_T;
    case tcs_closures:
      arg1 = (UNBNDP (arg1) ? EOL : scm_cons (arg1, args));
#ifndef RECKLESS
      if (scm_badargsp (CAR (CODE (proc)), arg1))
    goto wrongnumargs;
#endif
      args = EXTEND_ENV (CAR (CODE (proc)), arg1, ENV (proc));
      proc = CODE (proc);
      while (NNULLP (proc = CDR (proc)))
    arg1 = EVALCAR (proc, args);
      return arg1;
    case tc7_contin:
      ASRTGO (NULLP (args), wrongnumargs);
      scm_throw (proc, arg1);
#ifdef CCLO
    case tc7_cclo:
      args = (UNBNDP(arg1) ? EOL : scm_cons (arg1, args));
      arg1 = proc;
      proc = CCLO_SUBR (proc);
      goto tail;
#endif
    wrongnumargs:
      scm_wta (proc, (char *) WNA, "apply");
    default:
    badproc:
      scm_wta (proc, (char *) ARG1, "apply");
      return arg1;
    }
}


PROC (s_map, "map", 2, 0, 1, scm_map);
#ifdef __STDC__
SCM
scm_map (SCM proc, SCM arg1, SCM args)
#else
SCM
scm_map (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
#endif
{
  long i;
  SCM res = EOL;
  SCM *pres = &res;
  SCM *ve = &args;        /* Keep args from being optimized away. */

  if (NULLP (arg1))
    return res;
  ASSERT (NIMP (arg1), arg1, ARG2, s_map);
  if (NULLP (args))
    {
      while (NIMP (arg1))
    {
      ASSERT (CONSP (arg1), arg1, ARG2, s_map);
      *pres = scm_cons (scm_apply (proc, CAR (arg1), listofnull), EOL);
      pres = &CDR (*pres);
      arg1 = CDR (arg1);
    }
      return res;
    }
  args = scm_vector (scm_cons (arg1, args));
  ve = VELTS (args);
#ifndef RECKLESS
  for (i = LENGTH (args) - 1; i >= 0; i--)
    ASSERT (NIMP (ve[i]) && CONSP (ve[i]), args, ARG2, s_map);
#endif
  while (1)
    {
      arg1 = EOL;
      for (i = LENGTH (args) - 1; i >= 0; i--)
    {
      if IMP
        (ve[i]) return res;
      arg1 = scm_cons (CAR (ve[i]), arg1);
      ve[i] = CDR (ve[i]);
    }
      *pres = scm_cons (scm_apply (proc, arg1, EOL), EOL);
      pres = &CDR (*pres);
    }
}


PROC (s_for_each, "for-each", 2, 0, 1, scm_for_each);
#ifdef __STDC__
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
#else
SCM
scm_for_each (proc, arg1, args)
     SCM proc;
     SCM arg1;
     SCM args;
#endif
{
  SCM *ve = &args;        /* Keep args from being optimized away. */
  long i;
  if NULLP (arg1)
    return UNSPECIFIED;
  ASSERT (NIMP (arg1), arg1, ARG2, s_for_each);
  if NULLP (args)
    {
      while NIMP (arg1)
    {
      ASSERT (CONSP (arg1), arg1, ARG2, s_for_each);
      scm_apply (proc, CAR (arg1), listofnull);
      arg1 = CDR (arg1);
    }
      return UNSPECIFIED;
    }
  args = scm_vector (scm_cons (arg1, args));
  ve = VELTS (args);
#ifndef RECKLESS
  for (i = LENGTH (args) - 1; i >= 0; i--)
    ASSERT (NIMP (ve[i]) && CONSP (ve[i]), args, ARG2, s_for_each);
#endif
  while (1)
    {
      arg1 = EOL;
      for (i = LENGTH (args) - 1; i >= 0; i--)
    {
      if IMP
        (ve[i]) return UNSPECIFIED;
      arg1 = scm_cons (CAR (ve[i]), arg1);
      ve[i] = CDR (ve[i]);
    }
      scm_apply (proc, arg1, EOL);
    }
}


#ifdef __STDC__
SCM
scm_closure (SCM code, SCM env)
#else
SCM
scm_closure (code, env)
     SCM code;
     SCM env;
#endif
{
  register SCM z;
  NEWCELL (z);
  SETCODE (z, code);
  ENV (z) = env;
  return z;
}


long scm_tc16_promise;
#ifdef __STDC__
SCM
scm_makprom (SCM code)
#else
SCM
scm_makprom (code)
     SCM code;
#endif
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_promise;
  return z;
}


#ifdef __STDC__
static int
prinprom (SCM exp, SCM port, int writing)
#else
static int
prinprom (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
#endif
{
  scm_puts ("#<promise ", port);
  scm_iprin1 (CDR (exp), port, writing);
  scm_putc ('>', port);
  return !0;
}


PROC (s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
#ifdef __STDC__
SCM
scm_makacro (SCM code)
#else
SCM
scm_makacro (code)
     SCM code;
#endif
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro;
  return z;
}


PROC (s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);
#ifdef __STDC__
SCM
scm_makmacro (SCM code)
#else
SCM
scm_makmacro (code)
     SCM code;
#endif
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro | (1L << 16);
  return z;
}


PROC (s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);
#ifdef __STDC__
SCM
scm_makmmacro (SCM code)
#else
SCM
scm_makmmacro (code)
     SCM code;
#endif
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = code;
  CAR (z) = scm_tc16_macro | (2L << 16);
  return z;
}


#ifdef __STDC__
static int
prinmacro (SCM exp, SCM port, int writing)
#else
static int
prinmacro (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
#endif
{
  if (CAR (exp) & (3L << 16))
    scm_puts ("#<macro", port);
  else
    scm_puts ("#<syntax", port);
  if (CAR (exp) & (2L << 16))
    scm_putc ('!', port);
  scm_putc (' ', port);
  scm_iprin1 (CDR (exp), port, writing);
  scm_putc ('>', port);
  return !0;
}

PROC (s_force, "force", 1, 0, 0, scm_force);
#ifdef __STDC__
SCM
scm_force (SCM x)
#else
SCM
scm_force (x)
     SCM x;
#endif
{
  ASSERT ((TYP16 (x) == scm_tc16_promise), x, ARG1, s_force);
  if (!((1L << 16) & CAR (x)))
    {
      SCM ans = scm_apply (CDR (x), EOL, EOL);
      if (!((1L << 16) & CAR (x)))
    {
      DEFER_INTS;
      CDR (x) = ans;
      CAR (x) |= (1L << 16);
      ALLOW_INTS;
    }
    }
  return CDR (x);
}

PROC (s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
#ifdef __STDC__
SCM
scm_copy_tree (SCM obj)
#else
SCM
scm_copy_tree (obj)
     SCM obj;
#endif
{
  SCM ans, tl;
  if IMP
    (obj) return obj;
  if VECTORP
    (obj)
    {
      sizet i = LENGTH (obj);
      ans = scm_make_vector (MAKINUM (i), UNSPECIFIED);
      while (i--)
    VELTS (ans)[i] = scm_copy_tree (VELTS (obj)[i]);
      return ans;
    }
  if NCONSP (obj)
    return obj;
/*  return scm_cons(scm_copy_tree(CAR(obj)), scm_copy_tree(CDR(obj))); */
  ans = tl = scm_cons (scm_copy_tree (CAR (obj)), UNSPECIFIED);
  while (NIMP (obj = CDR (obj)) && CONSP (obj))
    tl = (CDR (tl) = scm_cons (scm_copy_tree (CAR (obj)), UNSPECIFIED));
  CDR (tl) = obj;
  return ans;
}

static SCM system_transformer;

#ifdef __STDC__
SCM
scm_eval_3 (SCM obj, int copyp, SCM env)
#else
SCM
scm_eval_3 (obj, copyp, env)
     SCM obj;
     int copyp;
     SCM env;
#endif
{
  if (NIMP (CDR (system_transformer)))
    obj = scm_apply (CDR (system_transformer), obj, listofnull);
  else if (copyp)
    obj = scm_copy_tree (obj);
  return IMP(obj) ? obj : scm_ceval (obj, env);
}

#ifdef __STDC__
SCM
scm_top_level_env (SCM thunk)
#else
SCM
scm_top_level_env (thunk)
     SCM thunk;
#endif
{
  if (IMP(thunk))
    return EOL;
  else
    return scm_cons(thunk, (SCM)EOL);
}

PROC (s_eval2, "eval2", 2, 0, 0, scm_eval2);
#ifdef __STDC__
SCM
scm_eval2 (SCM obj, SCM env_thunk)
#else
SCM
scm_eval2 (obj, env_thunk)
     SCM obj;
     SCM env_thunk;
#endif
{
  return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk));
}

PROC (s_eval, "eval", 1, 0, 0, scm_eval);
#ifdef __STDC__
SCM
scm_eval (SCM obj)
#else
SCM
scm_eval (obj)
     SCM obj;
#endif
{
  return
    scm_eval_3(obj, 1, scm_top_level_env(CDR(scm_top_level_lookup_thunk_var)));
}

PROC (s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
#ifdef __STDC__
SCM
scm_eval_x (SCM obj)
#else
SCM
scm_eval_x (obj)
     SCM obj;
#endif
{
  return
    scm_eval_3(obj,
           0,
           scm_top_level_env (CDR (scm_top_level_lookup_thunk_var)));
}

#ifdef __STDC__
SCM
scm_definedp (SCM x, SCM env)
#else
SCM
scm_definedp (x, env)
     SCM x;
     SCM env;
#endif
{
  SCM proc = CAR (x = CDR (x));
  if (ISYMP (proc))
    return BOOL_T;
  else if(IMP(proc) || !SYMBOLP(proc))
    return BOOL_F;
  else
    {
      SCM vcell = scm_sym2vcell(proc, env_top_level(env), BOOL_F);
      return (vcell == BOOL_F || UNBNDP(CDR(vcell))) ? BOOL_F : BOOL_T;
    }
}

static scm_smobfuns promsmob =
{scm_markcdr, scm_free0, prinprom};

static scm_smobfuns macrosmob =
{scm_markcdr, scm_free0, prinmacro};

#ifdef __STDC__
SCM
scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ())
#else
SCM
scm_make_synt (name, macroizer, fcn)
     char *name;
     SCM (*macroizer) ();
     SCM (*fcn) ();
#endif
{
  SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
  long tmp = ((((CELLPTR) (CAR (symcell))) - scm_heap_org) << 8);
  register SCM z;
  if ((tmp >> 8) != ((CELLPTR) (CAR (symcell)) - scm_heap_org))
    tmp = 0;
  NEWCELL (z);
  SUBRF (z) = fcn;
  CAR (z) = tmp + tc7_subr_2;
  CDR (symcell) = macroizer (z);
  return CAR (symcell);
}


#ifdef __STDC__
void
scm_init_eval (void)
#else
void
scm_init_eval ()
#endif
{
  scm_tc16_promise = scm_newsmob (&promsmob);
  scm_tc16_macro = scm_newsmob (¯osmob);
  scm_i_apply = scm_make_subr ("apply", tc7_lsubr_2, scm_apply);
  system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
  scm_i_dot = CAR (scm_sysintern (".", SCM_UNDEFINED));
  scm_i_arrow = CAR (scm_sysintern ("=>", SCM_UNDEFINED));
  scm_i_else = CAR (scm_sysintern ("else", SCM_UNDEFINED));
  scm_i_unquote = CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
  scm_i_uq_splicing = CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));

  /* acros */
  scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote);
  scm_make_synt ("define", scm_makmmacro, scm_m_define);
  scm_make_synt (s_delay, scm_makacro, scm_m_delay);
  /* end of acros */

  scm_top_level_lookup_thunk_var =
    scm_sysintern("*top-level-lookup-thunk*", BOOL_F);

  scm_make_synt ("and", scm_makmmacro, scm_m_and);
  scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
  scm_make_synt ("case", scm_makmmacro, scm_m_case);
  scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
  scm_make_synt ("do", scm_makmmacro, scm_m_do);
  scm_make_synt ("if", scm_makmmacro, scm_m_if);
  scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda);
  scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let);
  scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
  scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
  scm_make_synt ("or", scm_makmmacro, scm_m_or);
  scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote);
  scm_make_synt ("set!", scm_makmmacro, scm_m_set);
  scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
  scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont);
  scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
#include "eval.x"
}